home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLJUMP.C < prev    next >
Text File  |  1986-05-17  |  3KB  |  136 lines
  1. /* xljump - execution context routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern CONTEXT *xlcontext;
  10. extern NODE *xlvalue,*xlenv;
  11. extern int xltrace,xldebug;
  12.  
  13. /* xlbegin - beginning of an execution context */
  14. xlbegin(cptr,flags,expr)
  15.   CONTEXT *cptr; int flags; NODE *expr;
  16. {
  17.     cptr->c_flags = flags;
  18.     cptr->c_expr = expr;
  19.     cptr->c_xlstack = xlstack;
  20.     cptr->c_xlenv = xlenv;
  21.     cptr->c_xltrace = xltrace;
  22.     cptr->c_xlcontext = xlcontext;
  23.     xlcontext = cptr;
  24. }
  25.  
  26. /* xlend - end of an execution context */
  27. xlend(cptr)
  28.   CONTEXT *cptr;
  29. {
  30.     xlcontext = cptr->c_xlcontext;
  31. }
  32.  
  33. /* xljump - jump to a saved execution context */
  34. xljump(cptr,type,val)
  35.   CONTEXT *cptr; int type; NODE *val;
  36. {
  37.     /* restore the state */
  38.     xlcontext = cptr;
  39.     xlstack = xlcontext->c_xlstack;
  40.     xlenv = xlcontext->c_xlenv;
  41.     xltrace = xlcontext->c_xltrace;
  42.     xlvalue = val;
  43.  
  44.     /* call the handler */
  45.     longjmp(xlcontext->c_jmpbuf,type);
  46. }
  47.  
  48. /* xltoplevel - go back to the top level */
  49. xltoplevel()
  50. {
  51.     findtarget(CF_TOPLEVEL,"no top level");
  52. }
  53.  
  54. /* xlcleanup - clean-up after an error */
  55. xlcleanup()
  56. {
  57.     findtarget(CF_CLEANUP,"not in a break loop");
  58. }
  59.  
  60. /* xlcontinue - continue from an error */
  61. xlcontinue()
  62. {
  63.     findtarget(CF_CONTINUE,"not in a break loop");
  64. }
  65.  
  66. /* xlgo - go to a label */
  67. xlgo(label)
  68.   NODE *label;
  69. {
  70.     CONTEXT *cptr;
  71.     NODE *p;
  72.  
  73.     /* find a tagbody context */
  74.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  75.     if (cptr->c_flags & CF_GO)
  76.         for (p = cptr->c_expr; consp(p); p = cdr(p))
  77.         if (car(p) == label)
  78.             xljump(cptr,CF_GO,p);
  79.     xlfail("no target for GO");
  80. }
  81.  
  82. /* xlreturn - return from a block */
  83. xlreturn(val)
  84.   NODE *val;
  85. {
  86.     CONTEXT *cptr;
  87.  
  88.     /* find a block context */
  89.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  90.     if (cptr->c_flags & CF_RETURN)
  91.         xljump(cptr,CF_RETURN,val);
  92.     xlfail("no target for RETURN");
  93. }
  94.  
  95. /* xlthrow - throw to a catch */
  96. xlthrow(tag,val)
  97.   NODE *tag,*val;
  98. {
  99.     CONTEXT *cptr;
  100.  
  101.     /* find a catch context */
  102.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  103.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  104.         xljump(cptr,CF_THROW,val);
  105.     xlfail("no target for THROW");
  106. }
  107.  
  108. /* xlsignal - signal an error */
  109. xlsignal(emsg,arg)
  110.   char *emsg; NODE *arg;
  111. {
  112.     CONTEXT *cptr;
  113.  
  114.     /* find an error catcher */
  115.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  116.     if (cptr->c_flags & CF_ERROR) {
  117.         if (cptr->c_expr && emsg)
  118.         xlerrprint("error",NULL,emsg,arg);
  119.         xljump(cptr,CF_ERROR,NIL);
  120.     }
  121.     xlfail("no target for error");
  122. }
  123.  
  124. /* findtarget - find a target context frame */
  125. LOCAL findtarget(flag,error)
  126.   int flag; char *error;
  127. {
  128.     CONTEXT *cptr;
  129.  
  130.     /* find a block context */
  131.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  132.     if (cptr->c_flags & flag)
  133.         xljump(cptr,flag,NIL);
  134.     xlabort(error);
  135. }
  136.